home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istlx / SCNLB2.MAC.f < prev    next >
Encoding:
Text File  |  1989-03-04  |  38.8 KB  |  1,426 lines
  1. C---------------------------------------------------------
  2. C
  3. C      FORTRAN 77 SCANNER MAIN CONTROL SUBROUTINE
  4. C      ------------------------------------------
  5. C
  6. C---------------------------------------------------------
  7. C
  8. C  LSTTKN      IS THE LAST TOKEN TYPE RETURNED
  9. C  CMTSTR      IS USED TO HOLD COMMENT BLOCKS
  10. C  NXTCMT      IS THE NEXT COMMENT LINE TO BE RETURNED
  11. C  LSTCMT      IS THE LAST COMMENT LINE IN CMTSTR
  12. C
  13.       SUBROUTINE XSCN77 (SRC, LST, TKNVAL, TKNLEN, TKNSTR, STATUS)
  14. C
  15. C  THIS PARAMETER SETS THE MAXIMUM LENGTH OF A COMMENT BLOCK IN
  16. C  LINES. NOTE THAT IT MUST BE SET TO THE SAME VALUE IN GETBUF
  17. C  AS IT DIMENSIONS AN ARRAY IN COMMON.
  18. C
  19.       INTEGER MAXCMT
  20.       PARAMETER (MAXCMT = 1000)
  21.  
  22.       COMMON /IOCNLS/ SOURCE,LISTNG
  23.       INTEGER         SOURCE,LISTNG
  24.       COMMON /TOKENC/ TKNTYP,KTFLAG,ITKNCH,TKNCHR(1327)
  25.       INTEGER         TKNTYP,       ITKNCH,TKNCHR
  26.       LOGICAL                KTFLAG
  27.       COMMON /TKNUMC/ TOKNUM, STMNUM, PUNUM, PUNAME
  28.       INTEGER         TOKNUM, STMNUM, PUNUM, PUNAME(134)
  29.       COMMON /CMTSAV/ CMTSTR, LSTCMT, NXTCMT, LSTTKN
  30.       INTEGER         LSTCMT, NXTCMT, CMTSTR(81, MAXCMT), LSTTKN
  31.       COMMON /ERROCC/ NRCVER
  32.       INTEGER         NRCVER
  33.       INTEGER         SRC,LST, STATUS, TKNVAL, TKNLEN, CMT, NXTNAM
  34.       INTEGER         TKNSTR(*), FIRST
  35.       INTEGER         LENGTH
  36. C---------------------------------------------------------
  37. C    TOOLPACK/1    Release: 2.4
  38. C---------------------------------------------------------
  39. C
  40. C  TKLAST = LAST TOKEN NUMBER
  41. C
  42.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  43.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  44.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  45.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  46.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  47.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  48.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  49.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  50.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  51.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  52.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  53.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  54.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  55.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  56.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  57.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  58.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  59.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  60.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  61.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  62.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  63.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  64.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  65.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  66.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  67.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  68.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  69.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  70.  
  71. C
  72.       SAVE
  73.       DATA FIRST/0/
  74. C
  75. C  INITIALISATION........
  76. C
  77.       IF(STATUS .EQ. -101) THEN
  78.         FIRST = 0
  79.         RETURN
  80.       ENDIF
  81.  
  82.       IF (FIRST .EQ. 0) THEN
  83.         TOKNUM = 0
  84.         STMNUM = 1
  85.         PUNUM  = 1
  86.         PUNAME(1) = 36
  87.         PUNAME(2) = 77
  88.         PUNAME(3) = 65
  89.         PUNAME(4) = 73
  90.         PUNAME(5) = 78
  91.         PUNAME(6) = 129
  92.         LISTNG = LST
  93.         SOURCE = SRC
  94.         NRCVER = 0
  95.         LSTTKN = 0
  96.         LSTCMT = 0
  97.         NXTCMT = 0
  98.         NXTNAM = 0
  99.         FIRST = 1
  100.         CALL INISCN
  101.       ENDIF
  102.  
  103.       IF(LSTTKN .EQ. TCMMNT) THEN
  104.         NXTCMT = NXTCMT + 1
  105.         IF(NXTCMT .GT. MAXCMT) NXTCMT = 1
  106.         IF(CMTSTR(1, NXTCMT) .NE. 36) THEN
  107.           TKNVAL = TCMMNT
  108.           CALL SCOPY(CMTSTR(1, NXTCMT), 1, TKNSTR, 1)
  109.           TKNLEN = LENGTH(TKNSTR)
  110.           STATUS = -2
  111.           RETURN
  112.         ENDIF
  113.       ELSE IF(LSTTKN .EQ. TZEOF) THEN
  114.           IF(NRCVER .LT. 0) THEN
  115.             STATUS = -1002
  116.           ELSE IF(NRCVER .GT. 0) THEN
  117.             STATUS = -1
  118.           ELSE
  119.             STATUS = -2
  120.           ENDIF
  121.         RETURN
  122.       ENDIF
  123.  
  124.       CALL SCANNR
  125.       STATUS = -2
  126.       LSTTKN = TKNTYP
  127.  
  128.       IF(TKNTYP .NE. TCMMNT) THEN
  129.         TKNVAL = TKNTYP
  130.         TKNLEN = ITKNCH
  131.         IF (ITKNCH .GT. 0) THEN
  132.           TKNCHR(ITKNCH+1) = 129
  133.           CALL SCOPY(TKNCHR, 1, TKNSTR, 1)
  134.         ENDIF
  135.         IF(TKNTYP .EQ. TZEOF) THEN
  136.           IF(NRCVER .LT. 0) THEN
  137.             STATUS = -1002
  138.           ELSE IF(NRCVER .GT. 0) THEN
  139.             STATUS = -1
  140.           ELSE
  141.             STATUS = -2
  142.           ENDIF
  143.         ELSE IF(TKNTYP .EQ. TZEOS) THEN
  144.           IF(NXTNAM .GT. 0) THEN
  145.             IF(NXTNAM .EQ. 1) THEN
  146.               CALL SCNERR(24)
  147.             ELSE IF(NXTNAM .EQ. 2) THEN
  148.               PUNAME(1) = 36
  149.               PUNAME(2) = 66
  150.               PUNAME(3) = 76
  151.               PUNAME(4) = 79
  152.               PUNAME(5) = 67
  153.               PUNAME(6) = 75
  154.               PUNAME(7) = 129
  155.             ELSE IF(NXTNAM .EQ. 3) THEN
  156.               PUNAME(1) = 36
  157.               PUNAME(2) = 77
  158.               PUNAME(3) = 65
  159.               PUNAME(4) = 73
  160.               PUNAME(5) = 78
  161.               PUNAME(6) = 129
  162.             ENDIF
  163.             NXTNAM = 0
  164.           ENDIF
  165.           STMNUM = STMNUM + 1
  166.         ELSE IF(TKNTYP .EQ. TEND) THEN
  167.           STMNUM = 0
  168.           PUNUM  = PUNUM + 1
  169.           PUNAME(1) = 36
  170.           PUNAME(2) = 77
  171.           PUNAME(3) = 65
  172.           PUNAME(4) = 73
  173.           PUNAME(5) = 78
  174.           PUNAME(6) = 129
  175.         ELSE IF(TKNTYP .EQ. TPROGR) THEN
  176.           NXTNAM = 3
  177.         ELSE IF(TKNTYP .EQ. TBLOCK) THEN
  178.           NXTNAM = 2
  179.         ELSE IF(TKNTYP .EQ. TSUBRO .OR. TKNTYP .EQ. TFUNCT) THEN
  180.           NXTNAM = 1
  181.         ELSE IF(TKNTYP .EQ. TNAME) THEN
  182.           IF(NXTNAM .GT. 0) THEN
  183.             CALL SCOPY(TKNSTR, 1, PUNAME, 1)
  184.             NXTNAM = 0
  185.           ENDIF
  186.         ENDIF
  187.       ELSE
  188.         TKNVAL = TCMMNT
  189.         NXTCMT = NXTCMT + 1
  190.         IF(NXTCMT .GT. MAXCMT) NXTCMT = 1
  191.         CALL SCOPY(CMTSTR(1, NXTCMT), 1, TKNSTR, 1)
  192.         TKNLEN = LENGTH(TKNSTR)
  193.       ENDIF
  194.  
  195.       END
  196. C-----------------------------------------------------------------------
  197. C
  198. C GET BUFFER
  199. C            GET A BUFFER OF TEXT. THE BUFFER IS 80 CHARACTERS LONG
  200. C            MAXIMUM (MBUFFR) AND IS RETURNED CONTAINING LBUFFR
  201. C            CHARACTERS. THE CHARACTERS REPRESENT A SINGLE LINE.
  202. C            THE ROUTINE MAINTAINS A ONE LINE LOOK AHEAD BUFFER IN
  203. C            'COPY'.
  204. C
  205.       SUBROUTINE GETBUF(MBUFFR,BUFFER,LBUFFR,EOLFLG,EOFFLG)
  206.  
  207.       INTEGER MBUFFR, BUFFER(*), LBUFFR
  208.       LOGICAL EOLFLG, EOFFLG
  209. C
  210.       INTEGER MAXCMT
  211.       PARAMETER (MAXCMT = 1000)
  212.  
  213.       COMMON /INSTCM/ INSTAT
  214.       INTEGER         INSTAT
  215.       COMMON /CNTCRD/ NCONTC, MCONTC
  216.       INTEGER         NCONTC, MCONTC
  217.       COMMON /IOCNLS/ SOURCE,LISTNG
  218.       INTEGER         SOURCE,LISTNG
  219.       COMMON /TKNUMC/ TOKNUM, STMNUM, PUNUM, PUNAME
  220.       INTEGER         TOKNUM, STMNUM, PUNUM, PUNAME(134)
  221.       COMMON /CMTSAV/ CMTSTR, LSTCMT, NXTCMT, LSTTKN
  222.       INTEGER         LSTCMT, NXTCMT, CMTSTR(81, MAXCMT), LSTTKN
  223. C
  224.       LOGICAL FLAG, LACMNT, CMTFLG
  225.       INTEGER LENGTH
  226. C
  227.       INTEGER I, IBEG, LISTOK, COPY(134)
  228.       INTEGER CONTCR
  229. C
  230.       SAVE
  231. C
  232. C  NOTE: INSTAT IS SET TO -1 BY BLOCK DATA AND IS THEN AT 0 UNTIL AN
  233. C        END-OF-FILE IS DETECTED.
  234. C
  235.       IF(INSTAT) 10, 70, 210
  236. C
  237. C FIRST CALL TO GETBUF, GET LOOKAHEAD CARD IMAGE
  238. C
  239.    10 INSTAT = 0
  240.       NCONTC = 0
  241.       LACMNT = .FALSE.
  242. C
  243. C  READ IN ANY COMMENT LINES THAT PRECEDE THE FIRST STATEMENT IN THE
  244. C  FILE.
  245. C
  246.    20 CONTINUE
  247.       CALL RDBUFF(COPY, FLAG, CMTFLG, SOURCE)
  248.       IF(FLAG) GO TO 210
  249.       IF(CMTFLG) THEN
  250.         IF(.NOT. LACMNT) LACMNT = .TRUE.
  251.         LSTCMT = LSTCMT + 1
  252.         IF(LSTCMT .GT. MAXCMT) LSTCMT = 1
  253.         IF(LSTCMT .EQ. NXTCMT) CALL FTLERR(9)
  254.         CALL SCOPY(COPY, 1, CMTSTR(1, LSTCMT), 1)
  255.         IF(LISTNG .NE. -1) THEN
  256.           CALL ZCHOUT('               .', LISTNG)
  257.           CALL ZPTMES(COPY, LISTNG)
  258.         ENDIF
  259.         GO TO 20
  260.       ENDIF
  261. C
  262. C FIRST STATEMENT FOUND
  263. C
  264.       IF(LACMNT) THEN
  265.         LSTCMT = LSTCMT + 1
  266.         IF(LSTCMT .GT. MAXCMT) LSTCMT = 1
  267.         IF(LSTCMT .EQ. NXTCMT) CALL FTLERR(9)
  268.         CMTSTR(1, LSTCMT) = 36
  269.       ENDIF
  270. C
  271. C PLACE LOOKAHEAD IMAGE INTO BUFFER
  272. C
  273.    70 CONTINUE
  274.       IF(LACMNT) THEN
  275.         BUFFER(1) = 35
  276.         LBUFFR = 1
  277.       ELSE
  278.         LBUFFR = 0
  279.       ENDIF
  280.       IF(NCONTC .GT. 0) THEN
  281.         IBEG = 7
  282.       ELSE
  283.         IBEG = 1
  284.       ENDIF
  285.       DO 90 I = IBEG, 73
  286.         LBUFFR = LBUFFR + 1
  287.         IF(COPY(I).LT.32) CALL SCNERR(11)
  288.         BUFFER(LBUFFR) = COPY(I)
  289.    90 CONTINUE
  290.  
  291.       LBUFFR = LBUFFR - 1
  292.       IF(LISTNG .NE. -1) THEN
  293.         IF(NCONTC .EQ. 0)  THEN
  294.           CALL ZPTINT(STMNUM, 5, LISTNG)
  295.           CALL ZCHOUT(' - ', LISTNG)
  296.           IF(LACMNT) THEN
  297.             CALL ZPTINT(TOKNUM+1, 6, LISTNG)
  298.           ELSE
  299.             CALL ZPTINT(TOKNUM, 6, LISTNG)
  300.           ENDIF
  301.         ELSE
  302.           CALL ZCHOUT('              .', LISTNG)
  303.         ENDIF
  304.         CALL PUTCH(32, LISTNG)
  305.         CALL ZPTMES(COPY, LISTNG)
  306.       ENDIF
  307. C
  308. C GET NEW LOOKAHEAD IMAGE
  309. C
  310.       LACMNT = .FALSE.
  311. C
  312. C  GET THE NEXT LOOK AHEAD LINE. COMMENTS ARE HANDLED IMMEDIATLY
  313. C  WHILE SEARCHING FOR THE NEXT LINE.
  314. C
  315.   120 CONTINUE
  316.       CALL RDBUFF(COPY, FLAG, CMTFLG, SOURCE)
  317.       IF(FLAG) GO TO 200
  318.       IF(CMTFLG) THEN
  319.         IF(.NOT. LACMNT) THEN
  320.           LACMNT = .TRUE.
  321.         ENDIF
  322.         LSTCMT = LSTCMT + 1
  323.         IF(LSTCMT .GT. MAXCMT) LSTCMT = 1
  324.         IF(LSTCMT .EQ. NXTCMT) CALL FTLERR(9)
  325.         CALL SCOPY(COPY, 1, CMTSTR(1, LSTCMT), 1)
  326.         IF(LISTNG .NE. -1) THEN
  327.           CALL ZCHOUT('               .', LISTNG)
  328.           CALL ZPTMES(COPY, LISTNG)
  329.         ENDIF
  330.         GO TO 120
  331.       ENDIF
  332. C
  333. C NON-COMMENT CARD IMAGE FOUND
  334. C
  335.       IF(LACMNT) THEN
  336.         LSTCMT = LSTCMT + 1
  337.         IF(LSTCMT .GT. MAXCMT) LSTCMT = 1
  338.         IF(LSTCMT .EQ. NXTCMT) CALL FTLERR(9)
  339.         CMTSTR(1, LSTCMT) = 36
  340.       ENDIF
  341.       CONTCR = COPY(6)
  342.       IF(CONTCR .EQ. 32 .OR. CONTCR .EQ. 48) THEN
  343.         NCONTC = 0
  344.         EOLFLG = .TRUE.
  345.         EOFFLG = .FALSE.
  346.         DO 165 I = LBUFFR, 7, -1
  347.           IF(BUFFER(I) .NE. 32) THEN
  348.             BUFFER(I + 1) = 129
  349.             LBUFFR = I
  350.             RETURN
  351.           ENDIF
  352.   165   CONTINUE
  353.         BUFFER(8) = 129
  354.         LBUFFR    = 7
  355.         RETURN
  356.       ENDIF
  357. C
  358. C CONTINUATION LINE HANDLING
  359. C
  360. C SCNERR 20 : NUMBER OF CONTINUATION LINES MUST BE LESS THAN 19
  361. C SCNERR 21 : LABEL FIELD OF CONTINUATION LINE IS NON-BLANK
  362. C
  363.       IF(NCONTC .GE. MCONTC) CALL SCNERR(20)
  364.       NCONTC = NCONTC + 1
  365.       DO 180 I = 1, 5
  366.         IF(COPY(I) .NE. 32) CALL SCNERR(21)
  367.   180 CONTINUE
  368.       EOLFLG = .FALSE.
  369.       EOFFLG = .FALSE.
  370.       RETURN
  371. C
  372. C LOOKAHEAD IS END OF FILE
  373. C
  374.   200 EOLFLG = .TRUE.
  375.       EOFFLG = .FALSE.
  376.       INSTAT = 1
  377.       RETURN
  378. C
  379. C CURRENT IMAGE IS END OF FILE
  380. C
  381.   210 CONTINUE
  382.       EOFFLG = .TRUE.
  383.       IF(LACMNT) CALL SCNERR(-1)
  384.  
  385.       END
  386. C----------------------------------------------------------------------
  387. C
  388. C  ACTUAL INPUT ROUTINE, NOTE THAT THIS IS REPLACABLE, WHEREAS THE
  389. C                        ROUTINE RDBUFF IS REUSABLE BY OTHER TOOLS
  390. C
  391.       INTEGER FUNCTION LXREAD(BUFFER, FD)
  392.  
  393.       INTEGER FD
  394.       INTEGER BUFFER(*)
  395.       INTEGER ZGTCMD
  396.  
  397.       LXREAD = ZGTCMD(BUFFER, FD)
  398.  
  399.       END
  400. C----------------------------------------------------------------------
  401. C
  402. C  READ ROUTINE - READ IN A LINE FROM THE SOURCE FILE, DECIDE
  403. C                 IF THE END OF FILE HAS BEEN REACHED, OR IF THE
  404. C                 LINE IS A COMMENT. PAD NON-COMMENT LINES TO 72
  405. C                 CHARACTERS (COMMENTS ARE TRUNCATED TO 80 CHARACTERS).
  406. C                 A READ ERROR IS RETURNED AS E-O-F.
  407. C
  408.       SUBROUTINE RDBUFF(BUFFER, EOFFLG, CMTFLG, FD)
  409.  
  410.       INTEGER BUFFER(*), FD
  411.       LOGICAL EOFFLG, CMTFLG
  412. C
  413.       INTEGER  LXREAD, ZLOWER, INDEXX, LENGTH
  414.       INTEGER  LENT, I, J, LEGAL(12), TEMP(134)
  415.       COMMON /CNTROL/ CMTLEN
  416.       INTEGER CMTLEN
  417.  
  418.       SAVE /CNTROL/, LEGAL
  419.  
  420.       DATA LEGAL/32,48,49,50,51,52,53,54,55,56,57,129/
  421. C
  422. C  GET THE NEXT LINE - CHECK FOR ERRORS AND END-OF-FILE
  423. C
  424.       LENT = LXREAD(BUFFER, FD)
  425.       IF(LENT .EQ. -100) THEN
  426.         EOFFLG   = .TRUE.
  427.         RETURN
  428.       ELSE IF(LENT.EQ.-1) THEN
  429.         CALL FTLERR(8)
  430.       ENDIF
  431.  
  432.       EOFFLG   = .FALSE.
  433.  
  434.       I = 1
  435.       CALL SKIPBL(BUFFER, I)
  436. C
  437. C  FIRST LOOK FOR LEGAL COMMENTS
  438. C
  439.       IF(BUFFER(1) .EQ. 67 .OR. BUFFER(1) .EQ. 42 .OR.
  440.      +   BUFFER(1) .EQ. 99 .OR. BUFFER(I) .EQ. 129  .OR.
  441.      +   I .GT. 72) THEN
  442.         CMTFLG = .TRUE.
  443.         BUFFER(CMTLEN+1) = 129
  444. C
  445. C  NOW ASSUMED COMMENTS
  446. C
  447.       ELSE IF(BUFFER(1).NE.9 .AND. INDEXX(LEGAL,BUFFER(1)).EQ.0) THEN
  448.         CMTFLG = .TRUE.
  449.         CALL SCNERR(-2)
  450.         BUFFER(CMTLEN+1) = 129
  451. C
  452. C  OK, LINE IS BELIEVED TO BE PART OF A STATEMENT
  453. C
  454. C  CHECK FOR AND REMOVE TABS THEN ENSURE THAT
  455. C
  456.       ELSE
  457.         CMTFLG = .FALSE.
  458.  
  459.         DO 100 I = 1, 6
  460.           IF(BUFFER(I) .EQ. 9) THEN
  461.             CALL SCNERR(-3)
  462.             BUFFER(I) = 129
  463.             CALL SCOPY(BUFFER, 1, TEMP, 1)
  464.             DO 200 J = I, 6
  465.               TEMP(J) = 32
  466.   200       CONTINUE
  467.             CALL SCOPY(BUFFER, I+1, TEMP, 7)
  468.             CALL SCOPY(TEMP, 1, BUFFER, 1)
  469.             LENT = LENGTH(BUFFER)
  470.             GO TO 110
  471.           ELSE IF(BUFFER(I) .EQ. 129) THEN
  472.             GO TO 110
  473.           ENDIF
  474.   100   CONTINUE
  475.  
  476.   110   CONTINUE
  477.         IF(LENT .LT. 72) THEN
  478.           DO 10 I = LENT + 1, 72
  479.             BUFFER(I) = 32
  480.    10     CONTINUE
  481.           BUFFER(73) = 129
  482.         ENDIF
  483.  
  484.       ENDIF
  485.  
  486.       END
  487. C-----------------------------------------------------------------
  488. C
  489. C  THE SCANNER ROUTINE. RETURNS ONE TOKEN PER CALL
  490. C
  491.       SUBROUTINE SCANNR
  492. C
  493.       INTEGER         SDNCPW, SDNCPS
  494.       PARAMETER (SDNCPW=31, SDNCPS=128)
  495.       COMMON /CHRBFC/ ICHAR, CBFSIZ, CBFEND, MCHAR, CHRBUF(1603)
  496.       INTEGER         ICHAR, CBFSIZ, CBFEND, MCHAR, CHRBUF
  497.       COMMON /CHICOM/ ERRCHI, EOLCHI, EOICHI, EOFCHI
  498.       INTEGER         ERRCHI, EOLCHI, EOICHI, EOFCHI
  499.       COMMON /AKTYPS/ KSTEP,  DSTEP,  CALL,   FECALL, VECALL, ELSE,
  500.      +                OUTKTK, OUTDTK, SCREEN, EVAL,   END,    ERR,
  501.      +                KADV,   DADV,   FCKADV, FCDADV, VCKADV, VCDADV,
  502.      +                ELKSTP, ELDSTP, KTSCRN, DTSCRN, KTEVAL, DTEVAL
  503.       INTEGER         KSTEP,  DSTEP,  CALL,   FECALL, VECALL, ELSE,
  504.      +                OUTKTK, OUTDTK, SCREEN, EVAL,   END,    ERR,
  505.      +                KADV,   DADV,   FCKADV, FCDADV, VCKADV, VCDADV,
  506.      +                ELKSTP, ELDSTP, KTSCRN, DTSCRN, KTEVAL, DTEVAL
  507.       COMMON /CURSTC/ ACT, CHAR, ERRORF, FBKUPC, NEWACT, ENDSCR
  508.       INTEGER         ACT, CHAR,         FBKUPC, NEWACT
  509.       LOGICAL                    ERRORF,                 ENDSCR
  510. C
  511. C  KSTACK - KEEP STACK, CONTAINS PAIRS OF START/END POINTERS TO KEPT STRINGS
  512. C  MKSTAC - THE SIZE OF KSTACK
  513. C  IKSTAC - THE KEEP STACK STACK-POINTER
  514. C  KEEPF  - KEEP FLAG, TRUE TO KEEP CHARACTERS
  515. C
  516.       COMMON /KSTAKC/ IKSTAC, MKSTAC, KSTACK(2500), FTOKEN, TOKEN, KEEPF
  517.       INTEGER         IKSTAC, MKSTAC, KSTACK, FTOKEN, TOKEN
  518.       LOGICAL         KEEPF
  519. C
  520. C  CSTACK - CALL STACK FOR ACTIONS
  521. C  MCSTAC - THE SIZE OF CSTACK
  522. C  ICSTAC - THE ACTION CALL STACK STACK-POINTER
  523. C
  524.       COMMON /CSTAKC/ ICSTAC, MCSTAC, CSTACK(100)
  525.       INTEGER         ICSTAC, MCSTAC, CSTACK
  526.       COMMON /TCMAXC/ MTKNCH
  527.       INTEGER         MTKNCH
  528.       COMMON /TOKENC/ TKNTYP, KTFLAG, ITKNCH, TKNCHR(1327)
  529.       INTEGER         TKNTYP,         ITKNCH, TKNCHR
  530.       LOGICAL                 KTFLAG
  531.       COMMON /NESTCM/ NSTELS
  532.       INTEGER         NSTELS
  533.       COMMON /TKNUMC/ TOKNUM, STMNUM, PUNUM, PUNAME
  534.       INTEGER         TOKNUM, STMNUM, PUNUM, PUNAME(134)
  535.       INTEGER ACTSIZ
  536.       PARAMETER (ACTSIZ = 2050)
  537.       COMMON /XCDONE/ AA1(ACTSIZ),AA2(ACTSIZ),AA3(ACTSIZ),
  538.      +                AA4(ACTSIZ),AA5(ACTSIZ)
  539.       INTEGER         AA1,AA2,AA3,AA4,AA5
  540.       COMMON /EXPTCM/ EXPONT(3)
  541.       INTEGER EXPONT
  542. C
  543.       LOGICAL FCADVF, TEMPF, IN
  544.       INTEGER I, IBEG, IEND, ITMP, NUM, TEMP
  545.       INTEGER EXPVAL
  546.       INTEGER OLDACT, BEGTOK, VAL, DIG, ATYPE, VALLC, DS
  547. C---------------------------------------------------------
  548. C    TOOLPACK/1    Release: 2.4
  549. C---------------------------------------------------------
  550. C
  551. C  TKLAST = LAST TOKEN NUMBER
  552. C
  553.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  554.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  555.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  556.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  557.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  558.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  559.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  560.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  561.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  562.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  563.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  564.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  565.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  566.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  567.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  568.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  569.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  570.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  571.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  572.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  573.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  574.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  575.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  576.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  577.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  578.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  579.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  580.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  581.  
  582.       SAVE
  583. C
  584. C START. INCREMENT THE TOKEN NUMBER
  585. C
  586.       TOKNUM = TOKNUM + 1
  587.    10 IF(FTOKEN .LT. IKSTAC) GO TO 20
  588.       IF(ENDSCR) GO TO 670
  589.       IF(ACT .NE. 0) GO TO 30
  590.       TKNTYP = TZEOF
  591.       ITKNCH = 0
  592.       RETURN
  593. C
  594.    20 ACT = KSTACK(FTOKEN)
  595.       ATYPE = AA1(ACT)
  596.       GO TO 340
  597. C
  598. C ADISP
  599.    30 TEMP = CHAR
  600.       IF(CHAR .LE. SDNCPS) TEMP = TEMP + 1
  601.  
  602.    31 CONTINUE
  603.         IF(IN(TEMP, AA2(ACT))) GO TO 50
  604.         ACT = ACT + 1
  605.       GO TO 31
  606. C
  607. C DISPATCH
  608.    50 ATYPE = AA1(ACT)
  609.       GO TO(210,230,250,260,280,310,320,320,320,450,
  610.      $      510,690, 60, 80,100,130,110,140,210,230,
  611.      $      320,320,450,450), ATYPE
  612. C
  613. C KADV - KEEP AND ADVANCE
  614. C
  615.    60 IF(.NOT. KEEPF) THEN
  616.         KEEPF = .TRUE.
  617.         IKSTAC = IKSTAC + 1
  618.         KSTACK(IKSTAC) = ICHAR
  619.       ENDIF
  620.       ICHAR = ICHAR + 1
  621.       CALL ADVANC(ICHAR,CHRBUF,AA2(ACT))
  622.       CHAR = CHRBUF(ICHAR)
  623.       ACT = AA5(ACT)
  624.       GO TO 30
  625. C
  626. C DADV - DELETE AND ADVANCE
  627. C
  628.    80 IF(KEEPF) THEN
  629.         KEEPF = .FALSE.
  630.         IKSTAC = IKSTAC + 1
  631.         IF(IKSTAC .GT. MKSTAC) CALL FTLERR(1)
  632.         KSTACK(IKSTAC) = ICHAR
  633.       ENDIF
  634.       ICHAR = ICHAR + 1
  635.       CALL ADVANC(ICHAR,CHRBUF,AA2(ACT))
  636.       CHAR = CHRBUF(ICHAR)
  637.       ACT = AA5(ACT)
  638.       GO TO 30
  639. C
  640. C FCKADV
  641. C
  642.   100 FCADVF = .TRUE.
  643.       GO TO 120
  644. C
  645. C VCKADV
  646. C
  647.   110 FCADVF = .FALSE.
  648. C FCKADV(2) , VCKADV(2)
  649.   120 DS = AA2(ACT)
  650.       VALLC = AA4(ACT)
  651.       VAL = EXPONT(VALLC)
  652.       IF(VAL .EQ. 0) GO TO 200
  653.       IF(KEEPF) GO TO 160
  654.       IKSTAC = IKSTAC + 1
  655.       KSTACK(IKSTAC) = ICHAR
  656.       KEEPF = .TRUE.
  657.       GO TO 160
  658. C
  659. C FCDADV
  660.   130 FCADVF = .TRUE.
  661.       GO TO 150
  662. C
  663. C VCDADV
  664.   140 FCADVF = .FALSE.
  665. C FCDADV(2) , VCDADV(2)
  666.   150 DS = AA2(ACT)
  667.       VALLC = AA4(ACT)
  668.       VAL = EXPONT(VALLC)
  669.       IF(VAL .EQ. 0) GO TO 200
  670.       IF(KEEPF) THEN
  671.         IKSTAC = IKSTAC + 1
  672.         IF(IKSTAC .GT. MKSTAC) CALL FTLERR(1)
  673.         KSTACK(IKSTAC) = ICHAR
  674.         KEEPF = .FALSE.
  675.       ENDIF
  676. C FCKADV(3) , FCDADV(3) , VCKADV(3) , VCDADV(3)
  677.   160 ICHAR = ICHAR + 1
  678.       VAL = VAL - 1
  679.       IF(VAL .EQ. 0) GO TO 190
  680.   170 TEMP = CHRBUF(ICHAR)
  681.       IF(TEMP .LT. SDNCPS) TEMP = TEMP + 1
  682.       IF(IN(TEMP,DS)) GO TO 160
  683.       IF(CHRBUF(ICHAR).NE. EOICHI) GO TO 180
  684.       TEMPF = KEEPF
  685.       OLDACT = ACT
  686.       CALL EOIERR
  687.       IF(ACT .NE. OLDACT) GO TO 30
  688.       IF(.NOT.TEMPF .OR. KEEPF) GO TO 170
  689.       IKSTAC = IKSTAC + 1
  690.       KSTACK(IKSTAC) = ICHAR
  691.       KEEPF = .TRUE.
  692.       GO TO 170
  693. C
  694. C CHAR NOT IN CHARACTER SET
  695. C
  696.   180 IF(.NOT.FCADVF) GO TO 190
  697.       ERRORF = .TRUE.
  698.       IF(NSTELS .GT. 0) GO TO 730
  699.       IF(CHRBUF(ICHAR).EQ. EOFCHI) GO TO 720
  700.       CHRBUF(ICHAR) = ERRCHI
  701.       GO TO 160
  702. C
  703.   190 CHAR = CHRBUF(ICHAR)
  704.   200 ACT = AA5(ACT)
  705.       GO TO 30
  706. C
  707. C KSTEP - KEEP AND STEP
  708. C
  709.   210 IF(.NOT. KEEPF) THEN
  710.         IKSTAC = IKSTAC + 1
  711.         KSTACK(IKSTAC) = ICHAR
  712.         KEEPF = .TRUE.
  713.       ENDIF
  714.       ICHAR = ICHAR + 1
  715.       CHAR = CHRBUF(ICHAR)
  716.       ACT = AA5(ACT)
  717.       GO TO 30
  718. C
  719. C DSTEP - DELETE AND STEP
  720. C
  721.   230 IF(KEEPF) THEN
  722.         IKSTAC = IKSTAC + 1
  723.         IF(IKSTAC .GT. MKSTAC) CALL FTLERR(1)
  724.         KSTACK(IKSTAC) = ICHAR
  725.         KEEPF = .FALSE.
  726.       ENDIF
  727.       ICHAR = ICHAR + 1
  728.       CHAR = CHRBUF(ICHAR)
  729.       ACT = AA5(ACT)
  730.       GO TO 30
  731. C
  732. C CALL
  733.   250 ICSTAC = ICSTAC + 1
  734.       IF(ICSTAC .GT. MCSTAC) CALL FTLERR(2)
  735.       CSTACK(ICSTAC) = ACT
  736.       ACT = AA3(ACT)
  737.       GO TO 30
  738. C
  739. C FECALL
  740.   260 VALLC = AA4(ACT)
  741.       VAL = EXPONT(VALLC)
  742.       IF(VAL .GT. 0) GO TO 270
  743.       ACT = AA5(ACT)
  744.       GO TO 30
  745. C
  746.   270 ICSTAC = ICSTAC + 2
  747.       IF(ICSTAC .GT. MCSTAC) CALL FTLERR(2)
  748.       CSTACK(ICSTAC-1) = VAL - 1
  749.       CSTACK(ICSTAC) = ACT
  750.       ACT = AA3(ACT)
  751.       GO TO 30
  752. C
  753. C VECALL
  754.   280 VALLC = AA4(ACT)
  755.       VAL = EXPONT(VALLC)
  756.       IF(VAL .NE. 0) GO TO 290
  757.       ACT = AA5(ACT)
  758.       GO TO 30
  759. C
  760.   290 ICSTAC = ICSTAC + 5
  761.       IF(ICSTAC .GT. MCSTAC) CALL FTLERR(2)
  762.       CSTACK(ICSTAC) = ACT
  763. C VECALL(2) , END VECALL(2)
  764.   300 NSTELS = NSTELS + 1
  765.       IF(NSTELS .EQ. 1) FBKUPC = ICHAR
  766.       CSTACK(ICSTAC-4) = IKSTAC
  767.       IF(KEEPF) CSTACK(ICSTAC-4) = -IKSTAC
  768.       CSTACK(ICSTAC-3) = TOKEN
  769.       IF(ERRORF) CSTACK(ICSTAC-3) = -TOKEN
  770.       CSTACK(ICSTAC-2) = ICHAR
  771.       CSTACK(ICSTAC-1) = VAL - 1
  772.       ACT = AA3(ACT)
  773.       GO TO 30
  774. C
  775. C ELSE
  776.   310 ICSTAC = ICSTAC + 4
  777.       IF(ICSTAC .GT. MCSTAC) CALL FTLERR(2)
  778.       CSTACK(ICSTAC-3) = IKSTAC
  779.       IF(KEEPF) CSTACK(ICSTAC-3) = -IKSTAC
  780.       CSTACK(ICSTAC-2) = TOKEN
  781.       IF(ERRORF) CSTACK(ICSTAC-2) = -TOKEN
  782.       CSTACK(ICSTAC-1) = ICHAR
  783.       CSTACK(ICSTAC) = ACT
  784.       IF(NSTELS .EQ. 0) FBKUPC = ICHAR
  785.       NSTELS = NSTELS + 1
  786.       ACT = AA3(ACT)
  787.       GO TO 30
  788. C
  789. C OUTKTK , OUTDTK , SCREEN , KTSCRN , DTSCRN
  790.   320 IF(KEEPF) THEN
  791.         IKSTAC = IKSTAC + 1
  792.         IF(IKSTAC .GT. MKSTAC) CALL FTLERR(1)
  793.         KSTACK(IKSTAC) = ICHAR
  794.         KEEPF = .FALSE.
  795.       END IF
  796. C OUTKTK(2), OUTDTK(2), SCREEN(2), KTSCRN(2), DTSCRN(2), KTEVAL(2), DTEV
  797.   330 NEWACT = AA5(ACT)
  798.       IKSTAC = IKSTAC + 2
  799.       KSTACK(IKSTAC-1) = 0
  800.       IF(ERRORF) KSTACK(IKSTAC-1) = -1
  801.       ERRORF = .FALSE.
  802.       IF(NSTELS .NE. 0) THEN
  803.         KSTACK(TOKEN) = ACT
  804.         TOKEN = IKSTAC
  805.         ACT = NEWACT
  806.         GO TO 30
  807.       END IF
  808. C
  809.   340 FTOKEN = FTOKEN + 1
  810.       IF(ATYPE .EQ. SCREEN .OR. ATYPE .EQ. KTSCRN .OR.
  811.      $  ATYPE .EQ. DTSCRN) GO TO 400
  812. C OUTKTK(3) , OUTDTK(3) , KTEVAL(3) , DTEVAL(3)
  813.       ITKNCH = 0
  814.       KTFLAG = .FALSE.
  815.       IF(ATYPE .EQ. OUTKTK .OR. ATYPE .EQ. KTEVAL) KTFLAG = .TRUE.
  816.   350 CONTINUE
  817.       IBEG = KSTACK(FTOKEN)
  818.       IF(IBEG .GT. 0) THEN
  819.         IF(KTFLAG) THEN
  820.           IEND = KSTACK(FTOKEN+1) - 1
  821.           DO 360 I = IBEG, IEND
  822.             ITKNCH = ITKNCH + 1
  823.             IF(ITKNCH .LE. MTKNCH) TKNCHR(ITKNCH) = CHRBUF(I)
  824.   360     CONTINUE
  825.         END IF
  826.         FTOKEN = FTOKEN + 2
  827.         GO TO 350
  828.       END IF
  829. C
  830.       IF(ITKNCH .GT. MTKNCH) THEN
  831.         CALL SCNERR(1)
  832.         ITKNCH = MTKNCH
  833.       ENDIF
  834.       FTOKEN = FTOKEN + 1
  835.       IF(IBEG .LT. 0) CALL SCNERR(2)
  836.       TKNTYP = AA4(ACT)
  837.       IF(FTOKEN .LT. IKSTAC) RETURN
  838. C
  839.       IKSTAC = 1
  840.       FTOKEN = 1
  841.       TOKEN = 1
  842.       ACT = NEWACT
  843.       RETURN
  844. C
  845. C SCREEN(3) , KTSCRN(3) , DTSCRN(3)
  846.   400 BEGTOK = KSTACK(FTOKEN)
  847.       IF(BEGTOK .LE. 0) THEN
  848.         BEGTOK = ICHAR
  849.         ITMP = ICHAR
  850.       ELSE
  851. C
  852.         ITMP = KSTACK(FTOKEN+1)
  853.   420   FTOKEN = FTOKEN + 2
  854.         IBEG = KSTACK(FTOKEN)
  855.         IF(IBEG .GT. 0) THEN
  856.           IEND = KSTACK(FTOKEN+1) - 1
  857.           DO 430 I = IBEG, IEND
  858.             IF(ITMP .EQ. MCHAR) ITMP = 1
  859.             CHRBUF(ITMP) = CHRBUF(I)
  860.             ITMP = ITMP + 1
  861.   430     CONTINUE
  862.           GO TO 420
  863.         END IF
  864.       END IF
  865. C
  866.       IF(IBEG .LT. 0) CALL SCNERR(3)
  867.       ICSTAC = ICSTAC + 7
  868. C FTLERR 2 : CALL STACK OVERFLOW
  869.       IF(ICSTAC .GT. MCSTAC) CALL FTLERR(2)
  870.       CSTACK(ICSTAC-6) = NEWACT
  871.       CSTACK(ICSTAC-5) = ICHAR
  872.       CSTACK(ICSTAC-4) = BEGTOK
  873.       ICHAR = BEGTOK
  874.       CHAR = CHRBUF(BEGTOK)
  875.       CSTACK(ICSTAC-3) = IKSTAC
  876.       CSTACK(ICSTAC-2) = CHRBUF(ITMP)
  877.       CHRBUF(ITMP) = EOFCHI
  878.       CSTACK(ICSTAC-1) = FTOKEN + 1
  879.       FTOKEN = IKSTAC
  880.       TOKEN = IKSTAC
  881.       KEEPF = .FALSE.
  882.       CSTACK(ICSTAC) = ACT
  883.       IF(AA4(ACT).GT. 0) NSTELS = NSTELS + 1
  884.       ACT = AA3(ACT)
  885.       GO TO 30
  886. C
  887. C EVAL , KTEVAL , DTEVAL
  888.   450 IF(KEEPF) THEN
  889.         IKSTAC = IKSTAC + 1
  890.         IF(IKSTAC .GT. MKSTAC) CALL FTLERR(1)
  891.         KSTACK(IKSTAC) = ICHAR
  892.         KEEPF = .FALSE.
  893.       ENDIF
  894.       NUM = 0
  895.       ITMP = TOKEN
  896.   470 IF(ITMP .NE. IKSTAC) THEN
  897.         IBEG = KSTACK(ITMP+1)
  898.         ITMP = ITMP + 2
  899.         IEND = KSTACK(ITMP) - 1
  900.         DO 480 I = IBEG, IEND
  901.           NUM =(NUM*10) + CHRBUF(I) - 48
  902.   480   CONTINUE
  903.         GO TO 470
  904.       END IF
  905. C
  906.       VALLC = AA3(ACT)
  907.       EXPONT(VALLC) = NUM
  908.       IF(ATYPE .NE. EVAL) GO TO 330
  909. C EVAL(2)
  910.       IF(ERRORF) THEN
  911. C ERROR 2 : ERROR IN TOKEN
  912.         CALL SCNERR(2)
  913.         ERRORF = .FALSE.
  914.       ENDIF
  915.       IKSTAC = TOKEN
  916.       ACT = AA5(ACT)
  917.       GO TO 30
  918. C
  919. C END
  920.   510 IF(CHAR .EQ. EOICHI) THEN
  921. C IF END IS ONLY ALTERNATIVE IN THIS STATE, DELAY CALL TO EOIERR UNTIL P
  922. C DECREMENTATION OF NSTELS (BY END VECALL) TO MAXIMIZE CHRBUF OVERLAP
  923.         IF(AA5(ACT) .NE. ACT) THEN
  924.           ACT = AA5(ACT)
  925.           CALL EOIERR
  926.           GO TO 30
  927.         ENDIF
  928.       END IF
  929. C
  930.       ACT = CSTACK(ICSTAC)
  931.       IF(ACT .EQ. 0) GO TO 10
  932. C
  933.       ATYPE = AA1(ACT)
  934.       GO TO(680,680,540,550,570,590,680,680,640,680,
  935.      $  680,680,680,680,680,680,680,680,680,680,
  936.      $  600,600,680,680), ATYPE
  937. C
  938. C END CALL
  939.   540 ICSTAC = ICSTAC - 1
  940.       ACT = AA5(ACT)
  941.       GO TO 30
  942. C
  943. C END FECALL
  944.   550 VAL = CSTACK(ICSTAC-1)
  945.       IF(VAL .GT. 0) GO TO 560
  946.       ICSTAC = ICSTAC - 2
  947.       ACT = AA5(ACT)
  948.       GO TO 30
  949. C
  950.   560 CSTACK(ICSTAC-1) = VAL - 1
  951.       ACT = AA3(ACT)
  952.       GO TO 30
  953. C
  954. C END VECALL
  955.   570 VAL = CSTACK(ICSTAC-1)
  956.       NSTELS = NSTELS - 1
  957. C CHECK IF EOIERR SHOULD BE CALLED, DELAYED TILL HERE SO THAT DECREMENTA
  958. C OF NSTELS WILL ALLOW MAXIMUM OVERLAP OF CHRBUF
  959.       IF(CHAR .EQ. EOICHI) THEN
  960.         OLDACT = ACT
  961.         CALL EOIERR
  962.         IF(ACT .NE. OLDACT) GO TO 30
  963.       ENDIF
  964.       IF(VAL .NE. 0) GO TO 300
  965.       ICSTAC = ICSTAC - 5
  966.       ACT = AA5(ACT)
  967.       IF(NSTELS .GT. 0 .OR. TOKEN .EQ. FTOKEN) GO TO 30
  968.       NEWACT = ACT
  969.       GO TO 20
  970. C
  971. C END ELSE
  972.   590 ICSTAC = ICSTAC - 4
  973.       NSTELS = NSTELS - 1
  974.       ACT = AA5(ACT)
  975.       IF(NSTELS .GT. 0 .OR. TOKEN .EQ. FTOKEN) GO TO 30
  976.       NEWACT = ACT
  977.       GO TO 20
  978. C
  979. C END KTSCRN , END DTSCRN
  980.   600 ENDSCR = .TRUE.
  981.       NSTELS = NSTELS - 1
  982.       IF(CHAR .NE. EOFCHI) GO TO 610
  983.       IF(TOKEN .EQ. FTOKEN) GO TO 670
  984.       NEWACT = ACT
  985.       GO TO 20
  986. C
  987. C END KTSCRN(2) , END DTSCRN(2) , ERR KTSCRN(2) , ERR DTSCRN(2)
  988.   610 FTOKEN = IKSTAC
  989.       TKNTYP = AA4(ACT)
  990.       ITKNCH = 0
  991.       IF(ATYPE .EQ. DTSCRN) THEN
  992.         KTFLAG = .FALSE.
  993.         RETURN
  994.       ENDIF
  995. C
  996.       KTFLAG = .TRUE.
  997.       ICHAR = CSTACK(ICSTAC-4)
  998.   620 IF(CHRBUF(ICHAR).EQ. EOFCHI) GO TO 630
  999.       ITKNCH = ITKNCH + 1
  1000.       IF(ITKNCH .LE. MTKNCH) TKNCHR(ITKNCH) = CHRBUF(ICHAR)
  1001.       ICHAR = ICHAR + 1
  1002.       IF(ICHAR .EQ. MCHAR) I = 1
  1003.       GO TO 620
  1004. C
  1005.   630 IF(ITKNCH .LE. MTKNCH) RETURN
  1006.       CALL SCNERR(1)
  1007.       ITKNCH = MTKNCH
  1008.       RETURN
  1009. C
  1010. C END SCREEN
  1011.   640 IF(CHAR .EQ. EOFCHI) GO TO 660
  1012.       CALL SCNERR(4)
  1013.   650 ICHAR = ICHAR + 1
  1014.       IF(ICHAR .EQ. MCHAR) ICHAR = 1
  1015.       IF(CHRBUF(ICHAR).NE. EOFCHI) GO TO 650
  1016. C END SCREEN(2) , ERR SCREEN(2)
  1017.   660 IF(.NOT.ERRORF) GO TO 670
  1018.       CALL SCNERR(5)
  1019.       ERRORF = .FALSE.
  1020. C
  1021. C END SCREEN(2) , END KTSCRN(3) , END DTSCRN(3) , ERR KTSCRN(3) , ERR KT
  1022. C
  1023.   670 ENDSCR = .FALSE.
  1024.       FTOKEN = CSTACK(ICSTAC-1)
  1025.       CHAR   = CSTACK(ICSTAC-2)
  1026.       CHRBUF(ICHAR) = CHAR
  1027.       IKSTAC = CSTACK(ICSTAC-3)
  1028.       KEEPF = .FALSE.
  1029.       ICHAR = CSTACK(ICSTAC-5)
  1030.       CHAR = CHRBUF(ICHAR)
  1031.       NEWACT = CSTACK(ICSTAC-6)
  1032.       ICSTAC = ICSTAC - 7
  1033.       IF(FTOKEN .LT. IKSTAC) GO TO 20
  1034.       IKSTAC = 1
  1035.       FTOKEN = 1
  1036.       TOKEN = 1
  1037.       ACT = NEWACT
  1038.       GO TO 30
  1039. C
  1040. C END-ERROR
  1041. C
  1042.   680 CALL FTLERR(3)
  1043. C ERR
  1044.   690 ACT = AA5(ACT)
  1045.       IF(CHAR .EQ. EOICHI) THEN
  1046.         CALL EOIERR
  1047.         GO TO 30
  1048.       END IF
  1049. C
  1050.   700 IF(NSTELS .GT. 0) GO TO 730
  1051.       IF(CHAR .NE. EOFCHI) THEN
  1052.         CHRBUF(ICHAR) = ERRCHI
  1053.         ERRORF = .TRUE.
  1054.         ICHAR  = ICHAR + 1
  1055.         CHAR   = CHRBUF(ICHAR)
  1056.         GO TO 30
  1057.       END IF
  1058. C
  1059.   720 IF(ICSTAC .LE. 0) THEN
  1060.         CALL SCNERR(6)
  1061.         ITKNCH = 0
  1062.         TKNTYP = TZEOF
  1063.         ACT = 0
  1064.         RETURN
  1065.       END IF
  1066. C
  1067.   730 ACT = CSTACK(ICSTAC)
  1068.       IF(ACT .EQ. 0) THEN
  1069.         CALL SCNERR(7)
  1070.         GO TO 10
  1071.       END IF
  1072. C
  1073.       ATYPE = AA1(ACT)
  1074.       GO TO(850,850,750,760,770,780,850,850,840,850,
  1075.      $  850,850,850,850,850,850,850,850,850,850,
  1076.      $  830,830,850,850), ATYPE
  1077. C
  1078. C ERR CALL
  1079.   750 ICSTAC = ICSTAC - 1
  1080.       GO TO 700
  1081. C
  1082. C ERR FCALL
  1083.   760 ICSTAC = ICSTAC - 2
  1084.       GO TO 700
  1085. C
  1086. C ERR VECALL
  1087.   770 ICSTAC = ICSTAC - 1
  1088. C ERR ELSE , ERR VECALL(2)
  1089.   780 ICHAR = CSTACK(ICSTAC-1)
  1090.       CHAR = CHRBUF(ICHAR)
  1091.       TOKEN = CSTACK(ICSTAC-2)
  1092.       ERRORF = .FALSE.
  1093.       IF(TOKEN .LE. 0) THEN
  1094.         TOKEN = -TOKEN
  1095.         ERRORF = .TRUE.
  1096.       END IF
  1097.       IKSTAC = CSTACK(ICSTAC-3)
  1098.       KEEPF = .FALSE.
  1099.       IF(IKSTAC .LE. 0) THEN
  1100.         IKSTAC = -IKSTAC
  1101.         KEEPF = .TRUE.
  1102.       END IF
  1103.       IF(ATYPE .EQ. VECALL) THEN
  1104.         ACT = AA5(ACT)
  1105.       ELSE
  1106.   810   ACT = AA4(ACT)
  1107.         ATYPE = AA1(ACT)
  1108.         IF (ATYPE.EQ.ELSE .OR. ATYPE.EQ.ELKSTP .OR.
  1109.      +      ATYPE.EQ.ELDSTP) THEN
  1110.           TEMP = CHAR
  1111.           IF(CHAR .LE. SDNCPS) TEMP = TEMP + 1
  1112.           IF(IN(TEMP,AA2(ACT))) THEN
  1113.             CSTACK(ICSTAC) = ACT
  1114.             ACT = AA3(ACT)
  1115.             GO TO 30
  1116.           ELSE
  1117.             GOTO 810
  1118.           END IF
  1119.         END IF
  1120.       END IF
  1121. C
  1122.       ICSTAC = ICSTAC - 4
  1123.       NSTELS = NSTELS - 1
  1124.       IF(NSTELS .GT. 0 .OR. TOKEN .EQ. FTOKEN) GO TO 30
  1125.       NEWACT = ACT
  1126.       GO TO 20
  1127. C
  1128. C ERR KTSCRN , ERR DTSCRN
  1129.   830 ERRORF = .FALSE.
  1130.       ENDSCR = .TRUE.
  1131.       NSTELS = NSTELS - 1
  1132.       FTOKEN = IKSTAC
  1133.       GO TO 610
  1134. C
  1135. C ERR SCREEN
  1136.   840 CALL SCNERR(8)
  1137.       GO TO 660
  1138. C
  1139. C ERR-ERR
  1140.   850 CALL FTLERR(4)
  1141. C
  1142.       END
  1143. C ----------------------------------------------------------------------
  1144. C
  1145.       SUBROUTINE EOIERR
  1146. C
  1147.       COMMON /BFFRCM/MBUFFR,BUFFER(82)
  1148.       INTEGER        MBUFFR,BUFFER
  1149.       COMMON /CSTAKC/ICSTAC,MCSTAC,CSTACK(100)
  1150.       INTEGER        ICSTAC,MCSTAC,CSTACK
  1151.       COMMON /CHRBFC/ICHAR,CBFSIZ,CBFEND,MCHAR,CHRBUF(1603)
  1152.       INTEGER        ICHAR,CBFSIZ,CBFEND,MCHAR,CHRBUF
  1153.       COMMON /KSTAKC/IKSTAC,MKSTAC,KSTACK(2500),FTOKEN,TOKEN,KEEPF
  1154.       INTEGER        IKSTAC,MKSTAC,KSTACK,FTOKEN,TOKEN
  1155.       LOGICAL        KEEPF
  1156.       COMMON /CHICOM/ERRCHI,EOLCHI,EOICHI,EOFCHI
  1157.       INTEGER        ERRCHI,EOLCHI,EOICHI,EOFCHI
  1158.       COMMON /CURSTC/ACT,CHAR,ERRORF,FBKUPC,NEWACT,ENDSCR
  1159.       INTEGER        ACT,CHAR,FBKUPC,NEWACT
  1160.       LOGICAL        ERRORF,ENDSCR
  1161.       COMMON /NESTCM/NSTELS
  1162.       INTEGER        NSTELS
  1163. C
  1164.       LOGICAL EOLFLG,EOFFLG
  1165.       INTEGER FCIBUF,FBCTMP,LBUFFR,ITOK,IBUF,I
  1166.       SAVE
  1167. C
  1168.       IF (ICHAR.GE.MCHAR) THEN
  1169.           IF (KEEPF) THEN
  1170.               IKSTAC = IKSTAC + 1
  1171.               IF (IKSTAC.GT.MKSTAC) CALL FTLERR(1)
  1172.               KSTACK(IKSTAC) = ICHAR
  1173.               KEEPF = .FALSE.
  1174.           END IF
  1175.           ICHAR = 1
  1176.           CHAR = CHRBUF(1)
  1177.           IF (CHAR.NE.EOICHI) RETURN
  1178.       END IF
  1179. C
  1180. C GETBUF STORES MBUFFR CHARACTERS INTO BUFFER
  1181. C
  1182.       CALL GETBUF(MBUFFR,BUFFER,LBUFFR,EOLFLG,EOFFLG)
  1183.       IF (EOFFLG) THEN
  1184.           CHRBUF(ICHAR) = EOFCHI
  1185.           CHAR = EOFCHI
  1186.           RETURN
  1187.       ELSE IF (ERRORF) THEN
  1188.           CALL SCNERR(9)
  1189.           ERRORF = .FALSE.
  1190.           ICHAR = 1
  1191.           ACT = 1
  1192.           IKSTAC = 1
  1193.           FTOKEN = 1
  1194.           TOKEN = 1
  1195.           KEEPF = .FALSE.
  1196.           ICSTAC = 1
  1197.           NSTELS = 0
  1198.           GO TO 300
  1199.       END IF
  1200. C
  1201.       IF (NSTELS.LE.0 .AND. .NOT. KEEPF) THEN
  1202.           IF (TOKEN.LT.IKSTAC) THEN
  1203. C
  1204. C  INPUT APPEARS TO BE COMING FROM SAVED STRINGS
  1205. C
  1206.               ICHAR = KSTACK(IKSTAC)
  1207.           ELSE
  1208.               ICHAR = 1
  1209.               GO TO 300
  1210.           END IF
  1211.       END IF
  1212.       ITOK = FTOKEN + 1
  1213.   100 CONTINUE
  1214.       IF (ITOK.LE.IKSTAC) THEN
  1215.           FCIBUF = KSTACK(ITOK)
  1216.           IF (FCIBUF.GT.0) THEN
  1217.               GO TO 200
  1218.           ELSE
  1219.               ITOK = ITOK + 2
  1220.               GO TO 100
  1221.           END IF
  1222.       END IF
  1223. C
  1224.       FCIBUF = ICHAR
  1225.   200 IF (FCIBUF.LE.ICHAR) FCIBUF = CBFEND + FCIBUF
  1226.       IF (NSTELS.NE.0) THEN
  1227.           FBCTMP = FBKUPC
  1228.           IF (FBKUPC.LE.ICHAR) FBCTMP = CBFEND + FBKUPC
  1229.           IF (FCIBUF.GT.FBCTMP) FCIBUF = FBCTMP
  1230.       END IF
  1231. C
  1232. C  CHECK FOR OVERFLOW, RESET IF FOUND
  1233. C
  1234.       IF (ICHAR+LBUFFR.GE.FCIBUF-1) THEN
  1235.           CALL SCNERR(10)
  1236.           ICHAR = 1
  1237.           ACT = 1
  1238.           IKSTAC = 1
  1239.           FTOKEN = 1
  1240.           TOKEN = 1
  1241.           KEEPF = .FALSE.
  1242.           ICSTAC = 1
  1243.           NSTELS = 0
  1244.       END IF
  1245. C
  1246. C COPY THE LATEST LINE INTO THE RING BUFFER
  1247. C
  1248.   300 IBUF = ICHAR
  1249.       DO 400 I = 1,LBUFFR
  1250.           CHRBUF(IBUF) = BUFFER(I)
  1251.           IBUF = IBUF + 1
  1252.           IF (IBUF.EQ.MCHAR) IBUF = 1
  1253.   400 CONTINUE
  1254.  
  1255.       IF (EOLFLG) THEN
  1256.           CHRBUF(IBUF) = EOLCHI
  1257.           IBUF = IBUF + 1
  1258.           IF (IBUF.EQ.MCHAR) IBUF = 1
  1259.       END IF
  1260.       CHRBUF(IBUF) = EOICHI
  1261.       CHAR = CHRBUF(ICHAR)
  1262.  
  1263.       END
  1264. C----------------------------------------------------------------------
  1265. C
  1266.       SUBROUTINE SCNERR(ERRNUM)
  1267.  
  1268.       INTEGER ERRNUM
  1269.       COMMON /ERRORC/ NRCVER
  1270.       INTEGER NRCVER
  1271.       COMMON /IOCNLS/ SOURCE,LISTNG
  1272.       INTEGER SOURCE,LISTNG
  1273.       COMMON /TKNUMC/ TOKNUM, STMNUM, PUNUM, PUNAME
  1274.       INTEGER TOKNUM, STMNUM, PUNUM, PUNAME(134), FD
  1275.       SAVE
  1276.  
  1277.       IF(LISTNG .EQ. -1) THEN
  1278.         FD = 2
  1279.       ELSE
  1280.         FD = LISTNG
  1281.       ENDIF
  1282. C
  1283. C  ERRORS
  1284. C
  1285.       IF(ERRNUM .EQ. 1) THEN
  1286.         CALL ZMESS
  1287.      + ('SCAN ERROR 1 : TOKEN TOO LONG.', FD)
  1288.       ELSE IF(ERRNUM .EQ. 2) THEN
  1289.         CALL ZMESS
  1290.      + ('SCAN ERROR 2 : ERROR IN TOKEN.', FD)
  1291.       ELSE IF(ERRNUM .EQ. 3) THEN
  1292.         CALL ZMESS
  1293.      + ('SCAN ERROR 3 : ERROR IN TOKEN TO BE SCREENED.', FD)
  1294.       ELSE IF(ERRNUM .EQ. 4) THEN
  1295.         CALL ZMESS
  1296.      + ('SCAN ERROR 4 : UNPROCESSED TEXT REMAINING TO BE SCREENED.',FD)
  1297.       ELSE IF(ERRNUM .EQ. 5) THEN
  1298.         CALL ZMESS
  1299.      + ('SCAN ERROR 5 : SCREEN ENDED IN ERROR ACTION.', FD)
  1300.       ELSE IF(ERRNUM .EQ. 6) THEN
  1301.         CALL ZMESS
  1302.      + ('SCAN ERROR 6 : EOF READ UNEXPECTEDLY.', FD)
  1303.       ELSE IF(ERRNUM .EQ. 7) THEN
  1304.         CALL ZMESS
  1305.      + ('SCAN ERROR 7 : SCAN ENDED IN ERROR ACTION.', FD)
  1306.       ELSE IF(ERRNUM .EQ. 8) THEN
  1307.         CALL ZMESS
  1308.      + ('SCAN ERROR 8 : SCREENED TOKEN ENDS UNEXPECTEDLY.', FD)
  1309.       ELSE IF(ERRNUM .EQ. 9) THEN
  1310.         CALL ZMESS
  1311.      + ('SCAN ERROR 9 : END OF BUFFER REACHED IN ERROR, RESET.',FD)
  1312.       ELSE IF(ERRNUM .EQ. 10) THEN
  1313.         CALL ZMESS
  1314.      + ('SCAN ERROR 10: BUFFER OVERFLOW , RESET.', FD)
  1315.       ELSE IF(ERRNUM .EQ. 20) THEN
  1316.         CALL ZMESS
  1317.      + ('SCAN ERROR 20: TOO MANY CONTINUATION LINES.', FD)
  1318.       ELSE IF(ERRNUM .EQ. 21) THEN
  1319.         CALL ZMESS
  1320.      + ('SCAN ERROR 21: NON-BLANK LABEL ON CONTINUATION LINE.', FD)
  1321.       ELSE IF(ERRNUM .EQ. 23) THEN
  1322.         CALL ZMESS
  1323.      + ('SCAN ERROR 23: INITIAL LINE LOOKED LIKE END STATEMENT.', FD)
  1324.       ELSE IF(ERRNUM .EQ. 24) THEN
  1325.         CALL ZMESS
  1326.      + ('SCAN ERROR 24: UNNAMED FUNCTION OR SUBROUTINE.', FD)
  1327. C
  1328. C  WARNINGS
  1329. C
  1330.       ELSE IF(ERRNUM .EQ. -1) THEN
  1331.         CALL ZMESS
  1332.      + ('SCAN WARNING : COMMENTS DELETED AFTER LAST PROGRAM UNIT.', FD)
  1333.       ELSE IF(ERRNUM .EQ. -2) THEN
  1334.         CALL ZMESS
  1335.      + ('SCAN WARNING : UNRECOGNIZED LINE, ASSUMED COMMENT.', FD)
  1336.       ELSE IF(ERRNUM .EQ. -3) THEN
  1337.         CALL ZMESS
  1338.      + ('SCAN WARNING : TAB IN LABEL FIELD.', FD)
  1339. C
  1340. C  WHO KNOWS?
  1341. C
  1342.       ELSE
  1343.         CALL ZMESS
  1344.      + ('UNKNOWN SCAN ERROR: .', FD)
  1345.       ENDIF
  1346. C
  1347.       IF(ERRNUM .GT. 0) THEN
  1348.         NRCVER = MAX(1, NRCVER + 1)
  1349.       ELSE IF(ERRNUM .LT. 0) THEN
  1350.         IF(NRCVER .LE. 0) NRCVER = NRCVER - 1
  1351.         IF(ERRNUM .EQ. -1) RETURN
  1352.       ENDIF
  1353.  
  1354.       CALL ZCHOUT('               .', FD)
  1355.       CALL PUTLIN(PUNAME, FD)
  1356.       CALL ZCHOUT(' STATEMENT: .', FD)
  1357.       CALL ZPTINT(STMNUM, 1, FD)
  1358.       CALL ZCHOUT(' (NEAR TOKEN: .', FD)
  1359.       CALL ZPTINT(TOKNUM, 1, FD)
  1360.       CALL PUTCH(41, FD)
  1361.       CALL PUTCH(10, FD)
  1362.  
  1363.       END
  1364. C--------------------------------------------------------------------------
  1365. C
  1366. C  REPORT FATAL ERRORS ACCORDING TO ERROR NUMBER AND THEN QUIT
  1367. C
  1368.       SUBROUTINE FTLERR(FERNUM)
  1369.       INTEGER FERNUM
  1370. C
  1371.       COMMON /IOCNLS/ SOURCE,LISTNG
  1372.       INTEGER         SOURCE,LISTNG
  1373.       COMMON /TKNUMC/ TOKNUM, STMNUM, PUNUM, PUNAME
  1374.       INTEGER TOKNUM, STMNUM, PUNUM, PUNAME(134), FD
  1375.       SAVE
  1376. C
  1377.       IF(LISTNG .EQ. -1) THEN
  1378.         FD = 2
  1379.       ELSE
  1380.         FD = LISTNG
  1381.       ENDIF
  1382.       IF(FERNUM .EQ. 1) THEN
  1383.         CALL ZMESS
  1384.      +  ('SCAN FATAL ERROR 1: KEEP STACK OVERFLOW.', FD)
  1385.       ELSE IF(FERNUM .EQ. 2) THEN
  1386.         CALL ZMESS
  1387.      +  ('SCAN FATAL ERROR 2: CALL STACK OVERFLOW.', FD)
  1388.       ELSE IF(FERNUM .EQ. 3) THEN
  1389.         CALL ZMESS
  1390.      +  ('SCAN FATAL ERROR 3: ILLEGAL ACTION ON CALL STACK.', FD)
  1391.       ELSE IF(FERNUM .EQ. 4) THEN
  1392.         CALL ZMESS
  1393.      +  ('SCAN FATAL ERROR 4: ERROR IN BACKUP.', FD)
  1394.       ELSE IF(FERNUM .EQ. 5) THEN
  1395.         CALL ZMESS
  1396.      +  ('SCAN FATAL ERROR 5: EMPTY INPUT BUFFER TO SCANNER.', FD)
  1397.       ELSE IF(FERNUM .EQ. 6) THEN
  1398.         CALL ZMESS
  1399.      +  ('SCAN FATAL ERROR 6: INPUT LARGER THAN SCANNER BUFFER.', FD)
  1400.       ELSE IF(FERNUM .EQ. 7) THEN
  1401.         CALL ZMESS
  1402.      +  ('SCAN FATAL ERROR 7: SYNTACTIC STACK OVERFLOW.', FD)
  1403.       ELSE IF(FERNUM .EQ. 8) THEN
  1404.         CALL ZMESS
  1405.      +  ('SCAN FATAL ERROR 8: READ BUFFER ERROR.', FD)
  1406.       ELSE IF(FERNUM .EQ. 9) THEN
  1407.         CALL ZMESS
  1408.      +  ('SCAN FATAL ERROR 9: COMMENT BLOCK TOO LONG.', FD)
  1409.       ELSE
  1410.         CALL ZMESS
  1411.      +  ('SCAN UNKNOWN FATAL ERROR: .', FD)
  1412.       ENDIF
  1413. C
  1414.       CALL ZCHOUT('                    .', FD)
  1415.       CALL PUTLIN(PUNAME, FD)
  1416.       CALL ZCHOUT(' STATEMENT: .', FD)
  1417.       CALL ZPTINT(STMNUM, 1, FD)
  1418.       CALL ZCHOUT(' (NEAR TOKEN: .', FD)
  1419.       CALL ZPTINT(TOKNUM, 1, FD)
  1420.       CALL PUTCH(41, FD)
  1421.       CALL PUTCH(10, FD)
  1422. C
  1423.       CALL ZQUIT(-1)
  1424.  
  1425.       END
  1426.